﻿<ComClass(ClsVlax.ClassId, ClsVlax.InterfaceId, ClsVlax.EventsId)> _
Public Class ClsVlax

#Region "COM GUID"
    ' 这些 GUID 提供此类的 COM 标识 
    ' 及其 COM 接口。若更改它们，则现有的
    ' 客户端将不再能访问此类。
    Public Const ClassId As String = "5bfee13b-3cf8-4f78-8c24-21ea006bc9d3"
    Public Const InterfaceId As String = "c775c2a0-b193-4a14-939b-5fc1ef4061ce"
    Public Const EventsId As String = "b51e3d25-969c-470f-a51e-5c2701cdd308"
#End Region

    ' 可创建的 COM 类必须具有一个不带参数的 Public Sub New() 
    ' 否则， 将不会在 
    ' COM 注册表中注册此类，且无法通过
    ' CreateObject 创建此类。
    Public Sub New()
        MyBase.New()
    End Sub
    Private VL As Object
    Private VLF As Object

    Public Sub IntiClass(acApp As Object)

        If CInt(Left(acApp.Version, 2)) = 15 Then
            VL = acApp.GetInterfaceObject("VL.Application.1")
        ElseIf CInt(Left(acApp.Version, 2)) >= 16 Then
            VL = acApp.GetInterfaceObject("VL.Application.16")
        End If
        VLF = VL.ActiveDocument.Functions
    End Sub

    Public Function EvalLispExpression(lispStatement As String)

        Dim sym As Object, ret As Object, retval

        sym = VLF.Item("read").funcall(lispStatement)
        On Error Resume Next
        retval = VLF.Item("eval").funcall(sym)
        If Err().Number Then
            EvalLispExpression = ""
        Else
            EvalLispExpression = retval
        End If

    End Function

    Public Sub SetLispSymbol(symbolName As String, value As Object)
        Dim sym As Object, ret As Object
        sym = VLF.Item("read").funcall(symbolName)
        ret = VLF.Item("set").funcall(sym, value)
        EvalLispExpression("(defun translate-variant (data) (cond ((= (type data) 'list) (mapcar 'translate-variant data)) ((= (type data) 'variant) (translate-variant (vlax-variant-value data))) ((= (type data) 'safearray) (mapcar 'translate-variant (vlax-safearray->list data))) (t data)))")
        EvalLispExpression("(setq " & symbolName & "(translate-variant " & symbolName & "))")
        EvalLispExpression("(setq translate-variant nil)")

    End Sub

    Public Function GetLispSymbol(symbolName As String)

        Dim sym As Object
        sym = VLF.Item("read").funcall(symbolName)
        GetLispSymbol = VLF.Item("eval").funcall(sym)

    End Function

    Public Function GetLispList(symbolName As String) As Object

        Dim sym As Object, list As Object
        Dim Count, elements(), i As Long

        sym = VLF.Item("read").funcall(symbolName)
        list = VLF.Item("eval").funcall(sym)

        Count = VLF.Item("length").funcall(list)

        ReDim elements(0 To Count - 1)

        For i = 0 To Count - 1
            elements(i) = VLF.Item("nth").funcall(i, list)
        Next

        GetLispList = elements

    End Function

    Public Sub NullifySymbol(symbolName As Object)
        For i As Integer = LBound(symbolName) To UBound(symbolName)
            EvalLispExpression("(setq " & CStr(symbolName(i)) & " nil)")
        Next
    End Sub
    Protected Overrides Sub Finalize()
        VLF = Nothing
        VL = Nothing
        MyBase.Finalize()
    End Sub
End Class


